home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / xlisp.lbr / XLFMATH.CQ / xlfmath.c
Encoding:
C/C++ Source or Header  |  1985-06-03  |  15.3 KB  |  697 lines
  1.  
  2.                 /* xlmath - xlisp builtin arithmetic functions */
  3.  
  4. #ifdef CI_86
  5. #include "a:stdio.h"
  6. #include "xlisp.h"
  7. #endif
  8.  
  9. #ifdef AZTEC
  10. #include "a:stdio.h"
  11. #include "xlisp.h"
  12. #endif
  13.  
  14. #ifdef unix
  15. #include <stdio.h>
  16. #include <xlisp.h>
  17. #endif
  18.  
  19.  
  20.                             /* external variables */
  21.  
  22. extern struct node *xlstack;
  23.  
  24.  
  25.                               /* local variables */
  26.  
  27. static struct node *true;
  28.  
  29.  
  30.            /* forward declarations (the extern hack is for decusc) */
  31.  
  32. extern struct node *iarith();
  33. extern struct node *compare();
  34.  
  35.  
  36.                         /* Comparison operator defines */
  37.  
  38. #define  lss_op    1
  39. #define  leq_op    2
  40. #define  eql_op    3
  41. #define  neq_op    4
  42. #define  geq_op    5
  43. #define  gtr_op    6
  44.  
  45. #define  sign(n)   (((n)<0) ? -1 : (((n)>0) ? 1 : 0))
  46.  
  47.  
  48.                     /****************************************
  49.                     *  add - builtin function for addition  *
  50.                     ****************************************/
  51.  
  52. static struct node *add(args)
  53.   struct node *args;
  54. {
  55.     return iarith(args,'+');
  56. }
  57.  
  58.  
  59.                   /*******************************************
  60.                   *  sub - builtin function for subtraction  *
  61.                   *******************************************/
  62.  
  63. static struct node *sub(args)
  64.   struct node *args;
  65. {
  66.     return iarith(args,'-');
  67. }
  68.  
  69.  
  70.                  /**********************************************
  71.                  *  mul - builtin function for multiplication  *
  72.                  **********************************************/
  73.  
  74. static struct node *mul(args)
  75.   struct node *args;
  76. {
  77.     return iarith(args,'*');
  78. }
  79.  
  80.  
  81.                     /****************************************
  82.                     *  div - builtin function for division  *
  83.                     ****************************************/
  84.  
  85. static struct node *div(args)
  86.   struct node *args;
  87. {
  88.     return iarith(args,'/');
  89. }
  90.  
  91.  
  92.                     /***************************************
  93.                     *  mod - builtin function for modulus  *
  94.                     ***************************************/
  95.  
  96. static struct node *mod(args)
  97.   struct node *args;
  98. {
  99.     return iarith(args,'%');
  100. }
  101.  
  102.  
  103.                     /***************************************
  104.                     *  min - builtin function for minimum  *
  105.                     ***************************************/
  106.  
  107. static struct node *min(args)
  108.   struct node *args;
  109. {
  110.     return iarith(args,'m');
  111. }
  112.  
  113.  
  114.                     /***************************************
  115.                     *  max - builtin function for maximum  *
  116.                     ***************************************/
  117.  
  118. static struct node *max(args)
  119.   struct node *args;
  120. {
  121.     return iarith(args,'M');
  122. }
  123.  
  124.  
  125.                     /***************************************
  126.                     *  and - builtin function for modulus  *
  127.                     ***************************************/
  128.  
  129. static struct node *and(args)
  130.   struct node *args;
  131. {
  132.     return iarith(args,'&');
  133. }
  134.  
  135.  
  136.                      /**************************************
  137.                      *  or - builtin function for modulus  *
  138.                      **************************************/
  139.  
  140. static struct node *or(args)
  141.   struct node *args;
  142. {
  143.     return iarith(args,'|');
  144. }
  145.  
  146.  
  147.                              /**********************
  148.                              *  not - bitwise not  *
  149.                              **********************/
  150.  
  151. static struct node *not(args)
  152.   struct node *args;
  153. {
  154.     struct node *rval;
  155.     int val;
  156.  
  157.     val = xlevmatch(INT,&args)->n_int;      /* Evaluate the argument */
  158.     xllastarg(args);
  159.  
  160.     rval = newnode(INT);
  161.     rval->n_int = ~val;
  162.     return (rval);
  163. }
  164.  
  165.  
  166.                            /*************************
  167.                            *  abs - absolute value  *
  168.                            *************************/
  169.  
  170. static struct node *abs(args)
  171.   struct node *args;
  172. {
  173.     struct node *rval, *argp;
  174.  
  175.     switch (gettype(argp = xlevarg(&args)))
  176.     {
  177.     case INT:
  178.          xllastarg(args);
  179.          rval = newnode(INT);
  180.          if ((rval->n_int = argp->n_int) < 0)
  181.               rval->n_int *= -1;
  182.          break;
  183.  
  184. #ifdef REALS
  185.     case REAL:
  186.          xllastarg(args);
  187.          rval = newnode(REAL);
  188.          if ((rval->n_real = argp->n_real) < 0)
  189.               rval->n_real *= -1;
  190.          break;
  191. #endif
  192.  
  193.     default:
  194.          xlfail("bad argument type");
  195.     }
  196.  
  197.     return (rval);
  198. }
  199.  
  200.  
  201. #ifdef REALS
  202.  
  203.                           /****************************
  204.                           *  fix - integer from real  *
  205.                           ****************************/
  206.  
  207. static struct node *fix(args)
  208.   struct node *args;
  209. {
  210.     struct node *rval, *argp;
  211.  
  212.     switch (gettype(argp = xlevarg(&args)))
  213.     {
  214.     case INT:
  215.          xllastarg(args);
  216.          rval = newnode(INT);
  217.          rval->n_int = argp->n_int;
  218.          break;
  219.  
  220.     case REAL:
  221.          xllastarg(args);
  222.          rval = newnode(INT);
  223.          rval->n_int = (int) argp->n_real;
  224.          break;
  225.  
  226.     default:
  227.          xlfail("bad argument type");
  228.     }
  229.  
  230.     return (rval);
  231. }
  232.  
  233.  
  234.                        /******************************
  235.                        *  float - real from integer  *
  236.                        ******************************/
  237.  
  238. static struct node *lfloat(args)
  239.   struct node *args;
  240. {
  241.     struct node *rval, *argp;
  242.  
  243.     switch (gettype(argp = xlevarg(&args)))
  244.     {
  245.     case INT:
  246.          xllastarg(args);
  247.          rval = newnode(REAL);
  248.          rval->n_real = argp->n_int;
  249.          break;
  250.  
  251.     case REAL:
  252.          xllastarg(args);
  253.          rval = newnode(REAL);
  254.          rval->n_real = argp->n_real;
  255.          break;
  256.  
  257.     default:
  258.          xlfail("bad argument type");
  259.     }
  260.  
  261.     return (rval);
  262. }
  263.  
  264.  
  265.                /*************************************************
  266.                *  farith - common floating arithmetic function  *
  267.                *************************************************/
  268.  
  269. static struct node *farith(ival, oldstk, arg, val, ifunct, funct)
  270.     struct node *oldstk, *arg, *val;
  271.     int ival;
  272.     char ifunct, funct;
  273. {
  274.     struct node *rval;
  275.     long float rslt = (long float) ival, arg_val;
  276.     int arg_typ = REAL;
  277.  
  278.     while(1)
  279.     {
  280.         if (arg_typ == INT)
  281.             arg_val = (long float) (val->n_ptr)->n_int;
  282.         else
  283.         if (arg_typ == REAL)
  284.             arg_val = (val->n_ptr)->n_real;
  285.         else
  286.             xlfail("bad argument type");
  287.  
  288.         switch (ifunct)
  289.         {
  290.         case '+':
  291.             rslt += arg_val;
  292.             break;
  293.  
  294.         case '-':
  295.             rslt -= arg_val;
  296.             break;
  297.  
  298.         case '*':
  299.             rslt *= arg_val;
  300.             break;
  301.  
  302.         case '/':
  303.             rslt /= arg_val;
  304.             break;
  305.  
  306.         case '%':
  307.         case '&':
  308.         case '|':
  309.             xlfail("bad argument type");
  310.  
  311.         case 'm':
  312.             if (rslt > arg_val)
  313.                 rslt = arg_val;
  314.             break;
  315.  
  316.         case 'M':
  317.             if (rslt < arg_val)
  318.                 rslt = arg_val;
  319.            break;
  320.         }
  321.  
  322.         ifunct = funct;
  323.  
  324.         if (arg->n_ptr == NULL)
  325.              break;
  326.  
  327.         arg_typ = gettype((val->n_ptr = xlevarg(&(arg->n_ptr))));
  328.     }
  329.  
  330.     rval = newnode(REAL);
  331.     rval->n_real = rslt;
  332.  
  333.     xlstack = oldstk;
  334.     return (rval);
  335. }
  336. #endif
  337.  
  338.  
  339.                     /***************************************
  340.                     *  arith - common arithmetic function  *
  341.                     ***************************************/
  342.  
  343. static struct node *iarith(args,funct)
  344.     struct node *args;
  345.     char funct;
  346. {
  347.     struct node *oldstk,arg,val,*rval;
  348.     int rslt, arg_val;
  349.  
  350.     oldstk = xlsave(&arg,&val,NULL);   /* Create a new stack frame */
  351.  
  352.     arg.n_ptr = args;                  /* Get first parameter */
  353.  
  354.     arg_val = gettype((val.n_ptr = xlevarg(&arg.n_ptr)));
  355.  
  356. #ifdef REALS
  357.     if (arg_val == REAL)
  358.          return farith(0, oldstk, &arg, &val, '+', funct);
  359. #endif
  360.  
  361.     if (arg_val != INT)
  362.         xlfail("bad argument type");
  363.  
  364.     rslt = val.n_ptr->n_int;
  365.  
  366.     while (arg.n_ptr != NULL)
  367.     {
  368.         arg_val = gettype((val.n_ptr = xlevarg(&arg.n_ptr)));
  369.  
  370. #ifdef REALS
  371.         if (arg_val == REAL)
  372.             return farith(rslt, oldstk, &arg, &val, funct, funct);
  373. #endif
  374.  
  375.         if (arg_val != INT)
  376.             xlfail("bad argument type");
  377.  
  378.         arg_val = val.n_ptr->n_int;
  379.  
  380.         switch (funct)
  381.         {
  382.         case '+':
  383.             rslt += arg_val;
  384.             break;
  385.  
  386.         case '-':
  387.             rslt -= arg_val;
  388.             break;
  389.  
  390.         case '*':
  391.             rslt *= arg_val;
  392.             break;
  393.  
  394.         case '/':
  395.             rslt /= arg_val;
  396.             break;
  397.  
  398.         case '%':
  399.             rslt %= arg_val;
  400.             break;
  401.  
  402.         case '&':
  403.             rslt &= arg_val;
  404.             break;
  405.  
  406.         case '|':
  407.             rslt |= arg_val;
  408.             break;
  409.  
  410.         case 'm':
  411.             if (rslt > arg_val)
  412.                 rslt = arg_val;
  413.             break;
  414.  
  415.         case 'M':
  416.             if (rslt < arg_val)
  417.                 rslt = arg_val;
  418.            break;
  419.         }
  420.     }
  421.  
  422.     rval = newnode(INT);
  423.     rval->n_int = rslt;
  424.  
  425.     xlstack = oldstk;
  426.     return (rval);
  427. }
  428.  
  429.  
  430.                             /***********************
  431.                             *  land - logical and  *
  432.                             ***********************/
  433.  
  434. static struct node *land(args)
  435.   struct node *args;
  436. {
  437.     struct node *oldstk,arg,*val;
  438.  
  439.     oldstk = xlsave(&arg,NULL);
  440.     arg.n_ptr = args;
  441.     val = true;
  442.  
  443.     while (arg.n_ptr != NULL)
  444.         if (xlevarg(&arg.n_ptr) == NULL)
  445.         {
  446.             val = NULL;
  447.             break;
  448.         }
  449.  
  450.     xlstack = oldstk;
  451.     return (val);
  452. }
  453.  
  454.  
  455.                              /*********************
  456.                              *  lor - logical or  *
  457.                              *********************/
  458.  
  459. static struct node *lor(args)
  460.   struct node *args;
  461. {
  462.     struct node *oldstk,arg,*val;
  463.  
  464.     oldstk = xlsave(&arg,NULL);
  465.     arg.n_ptr = args;
  466.     val = NULL;
  467.  
  468.     while (arg.n_ptr != NULL)
  469.         if (xlevarg(&arg.n_ptr) != NULL)
  470.         {
  471.             val = true;
  472.             break;
  473.         }
  474.  
  475.     xlstack = oldstk;
  476.     return (val);
  477. }
  478.  
  479.  
  480.                             /***********************
  481.                             *  lnot - logical not  *
  482.                             ***********************/
  483.  
  484. static struct node *lnot(args)
  485.   struct node *args;
  486. {
  487.     struct node *val;
  488.  
  489.     val = xlevarg(&args);
  490.     xllastarg(args);
  491.  
  492.     if (val == NULL)
  493.         return (true);
  494.     else
  495.         return (NULL);
  496. }
  497.  
  498.  
  499.                        /*********************************
  500.                        *  lss - builtin function for <  *
  501.                        *********************************/
  502.  
  503. static struct node *lss(args)
  504.   struct node *args;
  505. {
  506.     return (compare(args,lss_op));
  507. }
  508.  
  509.  
  510.                        /**********************************
  511.                        *  leq - builtin function for <=  *
  512.                        **********************************/
  513.  
  514. static struct node *leq(args)
  515.   struct node *args;
  516. {
  517.     return (compare(args,leq_op));
  518. }
  519.  
  520.  
  521.                        /**********************************
  522.                        *  eql - builtin function for ==  *
  523.                        **********************************/
  524.  
  525. static struct node *eql(args)
  526.   struct node *args;
  527. {
  528.     return (compare(args,eql_op));
  529. }
  530.  
  531.  
  532.                        /**********************************
  533.                        *  neq - builtin function for !=  *
  534.                        **********************************/
  535.  
  536. static struct node *neq(args)
  537.   struct node *args;
  538. {
  539.     return (compare(args,neq_op));
  540. }
  541.  
  542.  
  543.                        /**********************************
  544.                        *  geq - builtin function for >=  *
  545.                        **********************************/
  546.  
  547. static struct node *geq(args)
  548.   struct node *args;
  549. {
  550.     return (compare(args,geq_op));
  551. }
  552.  
  553.  
  554.                        /*********************************
  555.                        *  gtr - builtin function for >  *
  556.                        *********************************/
  557.  
  558. static struct node *gtr(args)
  559.   struct node *args;
  560. {
  561.     return (compare(args,gtr_op));
  562. }
  563.  
  564.  
  565.                      /**************************************
  566.                      *  compare - common compare function  *
  567.                      **************************************/
  568.  
  569. static struct node *compare(args,funct)
  570.     struct node *args;
  571.     int funct;
  572. {
  573.     struct node *oldstk,arg,arg1,arg2;
  574.     int type1,type2,cmp;
  575.  
  576.     oldstk = xlsave(&arg,&arg1,&arg2,NULL);
  577.     arg.n_ptr = args;
  578.  
  579.     type1 = gettype(arg1.n_ptr = xlevarg(&arg.n_ptr));
  580.     type2 = gettype(arg2.n_ptr = xlevarg(&arg.n_ptr));
  581.     xllastarg(arg.n_ptr);
  582.  
  583.     if ((type1 == STR) && (type2 == STR))
  584.         cmp = strcmp(arg1.n_ptr->n_str,arg2.n_ptr->n_str);
  585.     else
  586.  
  587. #ifdef REALS
  588.     if (type1 == INT)
  589.     {
  590.         if (type2 == INT)
  591.             cmp = sign(arg1.n_ptr->n_int - arg2.n_ptr->n_int);
  592.         else
  593.  
  594.         if (type2 == REAL)
  595.             cmp = sign(arg1.n_ptr->n_int - arg2.n_ptr->n_real);
  596.         else
  597.             cmp = arg1.n_ptr - arg2.n_ptr;
  598.     }
  599.     else
  600.  
  601.     if (type1 == REAL)
  602.     {
  603.         if (type2 == INT)
  604.             cmp = sign(arg1.n_ptr->n_real - arg2.n_ptr->n_int);
  605.         else
  606.  
  607.         if (type2 == REAL)
  608.             cmp = sign(arg1.n_ptr->n_real - arg2.n_ptr->n_real);
  609.         else
  610.             cmp = arg1.n_ptr - arg2.n_ptr;
  611.     }
  612. #else
  613.  
  614.     if ((type1 == INT) && (type2 == INT))
  615.         cmp = sign(arg1.n_ptr->n_int - arg2.n_ptr->n_int);
  616. #endif
  617.  
  618.     else
  619.         cmp = arg1.n_ptr - arg2.n_ptr;
  620.  
  621.     xlstack = oldstk;
  622.  
  623.     switch (funct)
  624.     {
  625.     case lss_op:
  626.         return (cmp <  0) ? true : NULL;
  627.  
  628.     case leq_op:
  629.         return (cmp <= 0) ? true : NULL;
  630.  
  631.     case eql_op:
  632.         return (cmp == 0) ? true : NULL;
  633.  
  634.     case neq_op:
  635.         return (cmp != 0) ? true : NULL;
  636.  
  637.     case geq_op:
  638.         return (cmp >= 0) ? true : NULL;
  639.  
  640.     case gtr_op:
  641.         return (cmp >  0) ? true : NULL;
  642.  
  643.     }
  644.     xlfail("bad compare operator");
  645. }
  646.  
  647.  
  648.                  /*********************************************
  649.                  *  gettype - return the type of an argument  *
  650.                  *********************************************/
  651.  
  652. static int gettype(arg)
  653.   struct node *arg;
  654. {
  655.     if (arg == NULL)
  656.         return (LIST);
  657.     else
  658.         return (arg->n_type);
  659. }
  660.  
  661.  
  662.                 /************************************************
  663.                 *  xlminit - xlisp math initialization routine  *
  664.                 ************************************************/
  665.  
  666. xlminit()
  667. {
  668.     xlsubr("+",add);
  669.     xlsubr("-",sub);
  670.     xlsubr("*",mul);
  671.     xlsubr("/",div);
  672.     xlsubr("%",mod);
  673.     xlsubr("&",and);
  674.     xlsubr("|",or);
  675.     xlsubr("~",not);
  676.     xlsubr("<",lss);
  677.     xlsubr("<=",leq);
  678.     xlsubr("==",eql);
  679.     xlsubr("!=",neq);
  680.     xlsubr(">=",geq);
  681.     xlsubr(">",gtr);
  682.     xlsubr("&&",land);
  683.     xlsubr("||",lor);
  684.     xlsubr("!",lnot);
  685.     xlsubr("min",min);
  686.     xlsubr("max",max);
  687.     xlsubr("abs",abs);
  688.  
  689. #ifdef REALS
  690.     xlsubr("fix",fix);
  691.     xlsubr("float",lfloat);
  692. #endif
  693.  
  694.     true = xlenter("t");
  695.     true->n_symvalue = true;
  696. }
  697.